home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic 4 Database How-To / Visual Basic 4 Database - How-to (The Waite Group)(1995).iso / dataanal.fr_ / dataanal.fr
Text File  |  1995-07-20  |  9KB  |  316 lines
  1. VERSION 4.00
  2. Begin VB.Form frmDataAnal 
  3.    Caption         =   "Data Analysis"
  4.    ClientHeight    =   5640
  5.    ClientLeft      =   1515
  6.    ClientTop       =   1725
  7.    ClientWidth     =   6840
  8.    Height          =   6135
  9.    Left            =   1410
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   5640
  12.    ScaleWidth      =   6840
  13.    Top             =   1335
  14.    Width           =   7050
  15.    Begin VB.ComboBox lstResults 
  16.       Height          =   300
  17.       Left            =   1080
  18.       TabIndex        =   8
  19.       Top             =   1080
  20.       Width           =   3972
  21.    End
  22.    Begin VB.CommandButton cmdLoadSS 
  23.       Caption         =   "&Load Spreadsheet"
  24.       Enabled         =   0   'False
  25.       Height          =   330
  26.       Left            =   5172
  27.       TabIndex        =   6
  28.       Top             =   636
  29.       Width           =   1575
  30.    End
  31.    Begin VB.ComboBox lstTables 
  32.       Height          =   300
  33.       Left            =   1080
  34.       TabIndex        =   5
  35.       Top             =   720
  36.       Width           =   3972
  37.    End
  38.    Begin VB.CommandButton cmdQuit 
  39.       Caption         =   "&Quit"
  40.       Default         =   -1  'True
  41.       Height          =   330
  42.       Left            =   5160
  43.       TabIndex        =   3
  44.       Top             =   1044
  45.       Width           =   1575
  46.    End
  47.    Begin VB.CommandButton cmdSelectDB 
  48.       Caption         =   "&Select Database"
  49.       Height          =   330
  50.       Left            =   5160
  51.       TabIndex        =   2
  52.       Top             =   225
  53.       Width           =   1575
  54.    End
  55.    Begin VB.TextBox txtFileName 
  56.       BackColor       =   &H00C0C0C0&
  57.       Height          =   285
  58.       Left            =   1080
  59.       TabIndex        =   1
  60.       TabStop         =   0   'False
  61.       Top             =   240
  62.       Width           =   3975
  63.    End
  64.    Begin VB.Label Label3 
  65.       Alignment       =   1  'Right Justify
  66.       Caption         =   "Results:"
  67.       Height          =   252
  68.       Left            =   120
  69.       TabIndex        =   9
  70.       Top             =   1080
  71.       Width           =   852
  72.    End
  73.    Begin VB.OLE oleExcel 
  74.       Height          =   3732
  75.       Left            =   240
  76.       OLETypeAllowed  =   1  'Embedded
  77.       TabIndex        =   7
  78.       Top             =   1680
  79.       Width           =   6372
  80.    End
  81.    Begin VB.Label Label2 
  82.       Alignment       =   1  'Right Justify
  83.       Caption         =   "Table:"
  84.       Height          =   255
  85.       Left            =   120
  86.       TabIndex        =   4
  87.       Top             =   720
  88.       Width           =   855
  89.    End
  90.    Begin MSComDlg.CommonDialog cdSelectFile 
  91.       Left            =   6360
  92.       Top             =   600
  93.       _Version        =   65536
  94.       _ExtentX        =   847
  95.       _ExtentY        =   847
  96.       _StockProps     =   0
  97.       DefaultExt      =   "MDB"
  98.       DialogTitle     =   "Open Database File"
  99.       Filter          =   "Access Db (*.mdb)|*.mdb|All Files (*.*)|*.*"
  100.    End
  101.    Begin VB.Label Label1 
  102.       Alignment       =   1  'Right Justify
  103.       Caption         =   "Database:"
  104.       Height          =   255
  105.       Left            =   120
  106.       TabIndex        =   0
  107.       Top             =   240
  108.       Width           =   855
  109.    End
  110.    Begin VB.Menu mnuRaisan 
  111.       Caption         =   "Raisan"
  112.       Visible         =   0   'False
  113.    End
  114. End
  115. Attribute VB_Name = "frmDataAnal"
  116. Attribute VB_Creatable = False
  117. Attribute VB_Exposed = False
  118. Option Explicit
  119.  
  120. 'This project makes use of an Excel 5.0 worksheet,
  121. 'so the Excel 5.0 Object Library must be specified
  122. 'in the VB Tools Reference menu.
  123.  
  124. Dim dbSS As DATABASE
  125.  
  126. Const OLE_CreateEmbed As Integer = 0
  127. Const OLE_Activate As Integer = 7
  128. Const HOURGLASS As Integer = 11
  129.  
  130. Private Function ColName(colNo As Integer)
  131.     Dim alpha As String
  132.     
  133.     alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  134.     ColName = Mid$(alpha, colNo, 1)
  135. End Function
  136.  
  137. Private Sub cmdLoadSS_Click()
  138.     'If button is enabled, we can start
  139.     Dim rsTable As Recordset
  140.     Dim fld As Field
  141.     Dim fieldTypes() As String
  142.     Dim i As Integer, j As Integer
  143.     Dim rowNo As Integer
  144.     Dim cellRange As String
  145.     Dim cellValue As Variant
  146.     Dim cellPlace As String
  147.     Dim cellName As String
  148.     Dim totalRows As Integer
  149.     Dim nameExcel As String
  150.     Dim temp As String
  151.     Dim ssName As String
  152.     Dim saveCursor
  153.     
  154.     saveCursor = Me.MousePointer
  155.     Me.MousePointer = HOURGLASS
  156.     
  157.     'Create an array of all numerical fields to include in
  158.     'the spreadsheet
  159.     i = 0
  160.     For Each fld In dbSS.TableDefs(lstTables.TEXT).Fields
  161.         If fld.Type = dbInteger Or _
  162.                fld.Type = dbLong Or _
  163.                fld.Type = dbCurrency Or _
  164.                fld.Type = dbSingle Or _
  165.                fld.Type = dbDouble Then
  166.             i = i + 1
  167.             ReDim Preserve fieldTypes(i)
  168.             fieldTypes(i) = fld.Name
  169.         End If
  170.     Next
  171.     
  172.     If i = 0 Then
  173.         MsgBox "There are no numeric columns in the table. Exiting procedure."
  174.         Me.MousePointer = saveCursor
  175.         Exit Sub
  176.     End If
  177.     
  178.     'For convenience, limit the number of columns to 26 so
  179.     'we don't have to do anything fancy to columns AA, AB,
  180.     'and so on
  181.     i = IIf(i > 26, 26, i)
  182.     
  183.     'Open the recordset of the table
  184.     Set rsTable = dbSS.OpenRecordset(lstTables.TEXT)
  185.  
  186.     On Error GoTo OLError
  187.     oleExcel.CreateEmbed "", "Excel.Sheet.5"
  188.     On Error GoTo 0
  189.     ssName = oleExcel.object.Name
  190.     
  191.     Do While Not rsTable.EOF
  192.         rowNo = rowNo + 1
  193.         For j = 1 To i
  194.             cellValue = rsTable(fieldTypes(j))
  195.             oleExcel.object.Cells(rowNo, j).VALUE = cellValue
  196.         Next
  197.         rsTable.MoveNext
  198.     Loop
  199.     
  200.     'Insert the formulas to calculate the average, median, and
  201.     'standard deviation, and name the cells
  202.     totalRows = rowNo
  203.     rowNo = totalRows + 2
  204.     For j = 1 To i
  205.         cellRange = ColName(j) & "1:" & ColName(j) & Trim(Str(totalRows))
  206.         cellValue = "=AVERAGE(" & cellRange & ")"
  207.         cellPlace = "=" & ssName & "!" & ColName(j) & Trim(Str(rowNo)) & ":" & ColName(j) & Trim(Str(rowNo))
  208.         oleExcel.object.Cells(rowNo, j).VALUE = cellValue
  209.         cellName = "average" & Trim(Str(j))
  210.         oleExcel.object.Parent.Names.Add Name:=cellName, RefersTo:=cellPlace
  211.     Next
  212.     rowNo = rowNo + 1
  213.     For j = 1 To i
  214.         cellRange = ColName(j) & "1:" & ColName(j) & Trim(Str(totalRows))
  215.         cellValue = "=MEDIAN(" & cellRange & ")"
  216.         cellPlace = "=" & ssName & "!" & ColName(j) & Trim(Str(rowNo)) & ":" & ColName(j) & Trim(Str(rowNo))
  217.         oleExcel.object.Cells(rowNo, j).VALUE = cellValue
  218.         cellName = "median" & Trim(Str(j))
  219.         oleExcel.object.Parent.Names.Add Name:=cellName, RefersTo:=cellPlace
  220.     Next
  221.     rowNo = rowNo + 1
  222.     For j = 1 To i
  223.         cellRange = ColName(j) & "1:" & ColName(j) & Trim(Str(totalRows))
  224.         cellValue = "=STDEV(" & cellRange & ")"
  225.         cellPlace = "=" & ssName & "!" & ColName(j) & Trim(Str(rowNo)) & ":" & ColName(j) & Trim(Str(rowNo))
  226.         oleExcel.object.Cells(rowNo, j).VALUE = cellValue
  227.         cellName = "stdev" & Trim(Str(j))
  228.         oleExcel.object.Parent.Names.Add Name:=cellName, RefersTo:=cellPlace
  229.     Next
  230.     
  231.     'Lastly, put the results in the lstResults control
  232.     lstResults.Clear
  233.     For j = 1 To i
  234.         nameExcel = "average" & Trim(Str(j))
  235.         lstResults.AddItem fieldTypes(j) & " Average = " & oleExcel.object.Range(nameExcel).VALUE
  236.     Next
  237.     For j = 1 To i
  238.         nameExcel = "median" & Trim(Str(j))
  239.         lstResults.AddItem fieldTypes(j) & " Median = " & oleExcel.object.Range(nameExcel).VALUE
  240.     Next
  241.     For j = 1 To i
  242.         nameExcel = "stdev" & Trim(Str(j))
  243.         lstResults.AddItem fieldTypes(j) & " Standard Deviation = " & oleExcel.object.Range(nameExcel).VALUE
  244.     Next
  245.     lstResults.ListIndex = 0
  246.  
  247.     Me.MousePointer = saveCursor
  248.     Exit Sub
  249.  
  250. OLError:
  251.     MsgBox "An OLE error occurred, probably because Excel is not installed on this computer."
  252.     Unload Me
  253. End Sub
  254.  
  255. Private Sub cmdSelectDB_Click()
  256.     'Select a new database file to analyze
  257.     Dim strFileName As String
  258.     Dim X As TableDef
  259.     Dim saveCursor
  260.         
  261.     'Open the file open common dialog
  262.     cdSelectFile.ShowOpen
  263.     If Len(cdSelectFile.filename) Then
  264.         saveCursor = Me.MousePointer
  265.         Me.MousePointer = HOURGLASS
  266.         
  267.         txtFileName = cdSelectFile.filename
  268.         
  269.         'Open the database
  270.         Set dbSS = OpenDatabase(txtFileName)
  271.         
  272.         'Load the lstTables combo box
  273.         lstTables.Clear
  274.         If dbSS.TableDefs.Count Then
  275.             For Each X In dbSS.TableDefs
  276.                 'Exclude system tables
  277.                 If Not X.Name Like "MSys*" Then
  278.                     lstTables.AddItem X.Name
  279.                 End If
  280.             Next
  281.             lstTables.ListIndex = 0
  282.         End If
  283.         Me.MousePointer = saveCursor
  284.     Else
  285.         MsgBox "No file selected."
  286.     End If
  287. End Sub
  288.  
  289.  
  290.  
  291. Private Sub cmdQuit_Click()
  292.     Set dbSS = Nothing
  293.     End
  294. End Sub
  295.  
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  
  304.  
  305.  
  306. Private Sub lstTables_Click()
  307.     If Len(lstTables.TEXT) Then
  308.         cmdLoadSS.Enabled = True
  309.     Else
  310.         cmdLoadSS.Enabled = False
  311.     End If
  312. End Sub
  313.  
  314.  
  315.  
  316.